home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.0-b / stk-3 / blt-for-STk-3.0 / Demos / palette.stklos < prev    next >
Encoding:
Text File  |  1995-12-28  |  7.7 KB  |  219 lines
  1. ;;;;
  2. ;;;;  PURPOSE:  color palette (demo for drag&drop facilities)
  3. ;;;;
  4. ;;;; This file was originally written in Tcl for the BLT package by 
  5. ;;;;            Michael J. McLennan       Phone: (215)770-2842
  6. ;;;;            AT&T Bell Laboratories   E-mail: aluxpo!mmc@att.com
  7. ;;;;            Copyright (c) 1993  AT&T  All Rights Reserved
  8. ;;;; 
  9. ;;;;
  10. ;;;; Rewritten for STklos by Erick Gallesio
  11. ;;;;    Creation date:  6-Jul-1994 09:53
  12. ;;;; Last file update: 28-Dec-1995 19:05
  13.  
  14. (require "blt")
  15. (require "dd-protocol.stklos")
  16. (require "Scale")
  17. (require "Message")
  18. (require "Lentry")
  19.  
  20. (define (hexa n)
  21.   (string-append (number->string (quotient n 16) 16)
  22.          (number->string (modulo n 16) 16)))
  23.  
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25. ;;;;
  26. ;;;; Routines for packaging token windows...
  27. ;;;;
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29. (define (package-color color win)
  30.   (let* ((rgb (winfo 'rgb *root* color))
  31.      (r   (quotient (car rgb)   256))
  32.      (g   (quotient (cadr rgb)  256))
  33.      (b   (quotient (caddr rgb) 256)))
  34.     (make-drag&drop-label win :text "Color"
  35.                   :background color
  36.                   :foreground (if (> (+ r g b) 384) "black" "white"))
  37.     color))
  38.  
  39. (define (set-colors)
  40.   (let ((rgb (winfo 'rgb *root* (hash-table-get DragDrop 'color "black"))))
  41.     (set! (value Red)   (quotient (car rgb)   256))
  42.     (set! (value Green) (quotient (cadr rgb)  256))
  43.     (set! (value Blue)  (quotient (caddr rgb) 256))))
  44.  
  45. (define (package-number num win)
  46.   (make-drag&drop-label win :text (format #f "Number: ~A" num))
  47.   num)
  48.  
  49. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  50. ;;;;
  51. ;;;; A Class for color Slides
  52. ;;;;
  53. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  54. (define-class <Color-Scale>(<Tk-composite-widget> <Scale>)
  55.   ((sample     :accessor sample)
  56.    (scale      :accessor scale-of)
  57.    (background    :accessor background :init-keyword :background 
  58.         :allocation :special :propagate (frame scale))
  59.    (foreground    :accessor foreground :init-keyword :foreground
  60.         :allocation :special :propagate (frame scale))
  61.    (format     :accessor format-of 
  62.            :init-keyword :format))) ;; "#~A0000", "#00~A00" or "#0000~A"
  63.  
  64. (define-method initialize-composite-widget ((self <Color-Scale>) args parent)
  65.   (let ((s (make <Scale> :parent parent :from 0 :to 255 
  66.               :command (lambda (v) (set! (value self) v))
  67.               :orientation "horizontal"))
  68.     (f (make <Frame> :parent parent :width 20 :height 20 :border-width 3 
  69.               :relief "raised")))
  70.  
  71.     ;; Manage components
  72.     (slot-set! parent 'border-width 3)
  73.     (slot-set! parent 'relief "groove")
  74.     (pack s :side "left"  :expand #t :fill 'x)
  75.     (pack f :side "right" :fill 'y)
  76.  
  77.     ;; Assign slots
  78.     (slot-set! self 'Id     (Id s))
  79.     (slot-set! self 'sample f)
  80.     (slot-set! self 'scale  s)
  81.  
  82.     ;; Drag & Drop
  83.     (drag&drop-configure f 
  84.         :package-command (lambda (v) (package-color 
  85.                       (background (sample self)) v))
  86.         :source-handler  `(color ,dd-send-color))
  87.     (drag&drop-configure s 
  88.         :package-command (lambda (v) (package-number (value self) v))
  89.         :source-handler  `(number ,dd-send-number)
  90.         :target-handler  `(number ,(lambda ()
  91.                      (set! (value self)
  92.                            (hash-table-get DragDrop 
  93.                                    'number)))))))
  94.  
  95. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  96. ;;;;
  97. ;;;; procedure to change (fg or bg) color of a window and its descendants
  98. ;;;;
  99. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  100. (define (change-color widgets foreground)
  101.   (let* ((rgb  (winfo 'rgb *root* (hash-table-get DragDrop 'color "")))
  102.      (newR (quotient (car rgb)   256))
  103.      (newG (quotient (cadr rgb)  256))
  104.      (newB (quotient (caddr rgb) 256))
  105.      (actR (- newR 20))
  106.      (actG (- newG 20))
  107.      (actB (- newB 20))
  108.      (ncolor   (string-append "#" (hexa newR) (hexa newG) (hexa newB)))
  109.      (acolor   (string-append "#" (hexa actR) (hexa actG) (hexa actB))))
  110.       
  111.     (let ((change (lambda (win)
  112.             (if foreground 
  113.             (catch 
  114.              (set! (foreground win) ncolor)
  115.              (set! (active-foreground win) acolor))
  116.             (catch
  117.              (set! (background win) ncolor)
  118.              (set! (active-background win) acolor))))))
  119.  
  120.       (for-each (lambda (x) (change x)) widgets))))
  121.  
  122. ;;;; ----------------------------------------------------------------------
  123. ;;;; Main application window...
  124. ;;;; ----------------------------------------------------------------------
  125.  
  126. ;;;; main-sample
  127. (define main-sample (make <Label> :text "Color" :border-width 3 :relief "raised"))
  128.  
  129. (drag&drop-configure main-sample 
  130.        :package-command (lambda (w)
  131.               (package-color (format #f "#~A~A~A" 
  132.                          (hexa (value Red)) 
  133.                          (hexa (value Green))
  134.                          (hexa (value Blue)))
  135.                      w))
  136.        :source-handler `(color ,dd-send-color)
  137.        :target-handler `(color set-colors))
  138.  
  139. ;;;; explanation
  140. (define explanation (make <Message> :font "-Adobe-times-medium-r-normal--*-120*"
  141.                       :aspect 200 
  142.                     :text 
  143. "Press the third mouse button over a slider or a color sample and drag the token window around.  When the token becomes raised, it is over a target window.  
  144. Release the mouse button to drop the token and transfer information.  If the transfer fails, a \"no\" symbol is drawn on the token window.
  145. Try the following:
  146. - Drop a number from one slider onto another
  147. - Drop a color sample onto the Foreground/Background targets
  148. - Drop one of the slider color samples onto the main sample
  149. - Drop tokens from one palette application onto another"))
  150.  
  151. ;;;; entry
  152. (define ent (make <Labeled-Entry> :title "Color Value:" 
  153.                   :border-width 2
  154.                     :relief "sunken"))
  155.  
  156. (drag&drop-configure ent 
  157.     :package-command (lambda (w) (package-color (value ent) w))
  158.     :source-handler  `(color   ,dd-send-color)
  159.     :target-handler  '(color   ,(lambda ()
  160.                       (set! (value ent) 
  161.                         (hash-table-get DragDrop 'color)))))
  162.  
  163. (bind ent "<Key-Return>" '(hash-table-put! DragDrop 'color (value ent)))
  164.  
  165. ;;;; Red/Green/Blue
  166. (define Red   (make <Color-Scale> :text "Red"   :format "#~A0000"))
  167. (define Green (make <Color-Scale> :text "Green" :format "#00~A00"))
  168. (define Blue  (make <Color-Scale> :text "Blue"  :format "#0000~A"))
  169.  
  170. ;;;
  171. ;;; Overload the (setter value) of <Color-Scale> so that modification of a slider
  172. ;;; is reported to the main sample
  173. ;;;
  174. (define-method (setter value) ((s <Color-Scale>) v)
  175.   (set! (background (sample s)) (format #f (format-of s) (hexa v)))
  176.   (set! (value      (scale-of  s)) v)
  177.   (let ((r (value Red))
  178.     (g (value Green))
  179.     (b (value Blue)))
  180.     ;; Update main sample
  181.     (set! (background main-sample) (format #f "#~A~A~A" (hexa r) (hexa g) (hexa b)))
  182.     (set! (foreground main-sample) (if (> (+ r g b) 384) "black" "white"))))
  183.  
  184. ;;;;
  185. ;;;; Foreground/Background color inputs...
  186. ;;;;
  187. (define inputs (make <Frame>))
  188. (define bg     (make <Label>  :text "Background" 
  189.                        :parent inputs :border-width 3 :relief 'groove))
  190. (define fg     (make <Label>  :text "Foreground" 
  191.                   :parent inputs :border-width 3 :relief 'groove))
  192.  
  193. (drag&drop-configure bg :target-handler `(color ,(lambda ()
  194.                           (change-color *the-widgets* #f))))
  195. (drag&drop-configure fg :target-handler `(color ,(lambda ()
  196.                           (change-color *the-widgets* #t))))
  197.  
  198. ;;;; Quit
  199. (define quit   (make <Button> :text "Quit"
  200.                        :parent inputs :border-width 3 :command "exit"))
  201.  
  202. ;;;;
  203. ;;;; Pack all the widgets
  204. ;;;;
  205. (pack bg fg :side "left" :padx 5 :pady 5)
  206. (pack quit  :side "right" :padx 5 :pady 5)
  207.  
  208. (pack main-sample explanation  ent :expand #t :fill "both")
  209. (pack Red Green Blue :fill "both")
  210. (pack inputs :fill "x")
  211.  
  212. (wm 'minsize *root* 200 200)
  213. (wm 'maxsize *root* 1000 1000)
  214.  
  215. ;; List of widgets whose bg/fg is changed when a global change-color is done
  216. (define *the-widgets* (list explanation ent Red Green Blue inputs bg fg quit))
  217.  
  218. (set-colors)
  219.